home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / handler.t < prev    next >
Text File  |  1988-02-05  |  8KB  |  181 lines
  1. (herald handler (env tsys))
  2.  
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Generic handlers  needs frame.t
  28.  
  29.  
  30. (define *handlers*
  31.   (vector-fill (make-vector 32) handle-unused-tag))
  32.  
  33. (define handle-unused-tag
  34.   (object nil
  35.     ((print self port)
  36.      (format port "bad header type, addr = #x~x"
  37.              (descriptor->fixnum self)))))
  38.  
  39. (define handle-immediate
  40.   (object nil
  41.     ((print self port)
  42.      (format port "{Immediate_~s}"
  43.              (fixnum-ashl (descriptor->fixnum self) 2)))))                                              
  44.  
  45. (define handle-nonvalue
  46.   (object nil
  47.     ((print self port) (format port "#{Nonvalue}"))))
  48.  
  49. (define-simple-switch bytev-elision fixnum? 8)
  50.  
  51. (define-handler bytev
  52.   (let ((writer (lambda (port bytev count)
  53.                   (let ((len (cond ((null? count) (bytev-length bytev))
  54.                                    ((fx< count (bytev-length bytev))
  55.                                     count)
  56.                                    (else (bytev-length bytev))))
  57.                         (writec (if (iob? port) vm-write-char write-char)))
  58.                     (if count
  59.                         (if (fx< len (bytev-length bytev))
  60.                             (format port "#{Bytev (~a) " (object-hash bytev))
  61. ;++                            (format port "#[Bytev (~a) " (object-hash bytev))))
  62.                             (format port "#{Bytev (~a) " (object-hash bytev))))
  63.                     (do ((i 0 (fx+ i 1)))
  64.                         ((fx>= i len) (no-value))
  65.                       (let ((byte (bref bytev i)))
  66.                         (if (fx= (fx-rem i 2) 0) (space port))
  67.                         (writec port (digit->char (fx-ashr byte 4) 16))  
  68.                         (writec port (digit->char (fx-and byte 15) 16))))
  69.                     (if count
  70.                         (if (fx< len (bytev-length bytev))
  71.                             (write-string port " ... }")
  72. ;++                            (writec port #\])))
  73.                             (writec port #\})))
  74.                     (no-value)))))
  75.     (object nil
  76.       ((display self port)
  77.        (writer port self nil))
  78.       ((print self port)
  79.        (writer port self (bytev-elision)))
  80.       ((crawl-exhibit self)
  81.        (writer (standard-output) self (bytev-length self))))))
  82.  
  83. (define (make-bytev-for-read key port rt)
  84.   (let* ((l     (read-to-right-bracket port #\] (rt-with-radix rt 16)))
  85.          (l     (cdr l))
  86.          (bytev (make-bytev (fx-ashl (length l) 1))))
  87.     (format t "~x~%" l)
  88.     (iterate loop ((i 0) (l l))
  89.       (cond ((null? l) bytev)
  90.             (else
  91.              (set (bref-16 bytev i) (car l))
  92.              (loop (fx+ i 2) (cdr l)))))))
  93.  
  94. (define-handler foreign
  95.   (object nil
  96.     ((print self port)
  97.      (format port "#{Foreign~_~s~_~x}"
  98.              (foreign-name self)
  99.              (mref-integer self 4)))))
  100.  
  101. (define-handler template
  102.   (object nil
  103.     ((print-type-string obj) "Template")))
  104.  
  105. (define-handler vcell
  106.   (object nil
  107.      ((contents self)
  108.       (let ((z (vcell-contents self)))
  109.         (cond ((nonvalue? z)
  110.                (error "bound variable ~s has no value"
  111.                       (vcell-id self)))
  112.               (else z)))) 
  113.       ((set-contents self value)
  114.        (check-rebinding self nil set-contents)
  115.        (*set self value))
  116.       ((define-contents self value)
  117.          ;; kludge to allow (define x x)
  118.        (check-rebinding self t define-contents)
  119.        (*set self value))
  120.       ((locative? self) t)
  121.       ((identification self) (vcell-id self))
  122.       ((crawl-exhibit self)
  123.        (exhibit-standard-extend self %%vcell-size 0 0))
  124.       ((maybe-crawl-component self command)
  125.        (cond ((and (nonnegative-fixnum? command)
  126.                    (fx< command %%vcell-size))
  127.               (crawl-push (extend-pointer-elt self command)))
  128.              (else nil)))
  129.       ((print-type-string self) "Value-cell")))
  130.                                                               
  131. (define-handler unit
  132.   (object nil                          
  133.     ((compiled-code? self) '#t)
  134.     ((crawl-exhibit self)
  135.      (exhibit-standard-extend self (unit-length self) 0 0))
  136.     ((maybe-crawl-component self command)
  137.      (cond ((and (nonnegative-fixnum? command)
  138.                  (fx< command (unit-length self)))
  139.             (crawl-push (extend-pointer-elt self command)))
  140.            (else nil)))
  141.     ((get-loaded-file self) self)
  142.     ((loaded-file-herald self) (unit-herald self))
  143.     ((loaded-file-source self) (unit-source-filename self))
  144.     ((run-compiled-code self env) 
  145.      (ignore env)  ;++ should there be an env arg?
  146.      ((unit-top-level-forms self)))
  147.     ((identification self) 
  148.      (filename-name (herald-filename (unit-herald self))))
  149.     ((print-type-string self) "Unit")))
  150.  
  151. (define-handler true
  152.   (object nil
  153.     ((print obj port) (write-string port "#T"))))
  154.  
  155. (define-handler cell                                                   
  156.  (object nil
  157.     ((contents self) (cell-value self))
  158.     ((set-contents self value)
  159.      (set (cell-value self) value))
  160.     ((locative? self) t)
  161.     ((print self port) (format port "#{Cell~_~s}" (cell-value self)))))
  162.      
  163. ;;; Initialization
  164.  
  165. ;(set (vref *handlers* (fixnum-ashr header/template       2)) handle-template)
  166. ;(set (vref *handlers* (fixnum-ashr header/slice          2)) handle-slice)
  167. ;(set (vref *handlers* (fixnum-ashr header/symbol         2)) handle-symbol)
  168. ;(set (vref *handlers* (fixnum-ashr header/vcell          2)) handle-vcell)
  169. ;(set (vref *handlers* (fixnum-ashr header/general-vector 2)) handle-vector)
  170. ;(set (vref *handlers* (fixnum-ashr header/bytev          2)) handle-bytev)
  171. ;(set (vref *handlers* (fixnum-ashr header/text           2)) handle-text)
  172. ;(set (vref *handlers* (fixnum-ashr header/foreign        2)) handle-foreign)
  173. ;(set (vref *handlers* (fixnum-ashr header/cell           2)) handle-cell)
  174. ;(set (vref *handlers* (fixnum-ashr header/vframe         2)) handle-vframe)
  175. ;(set (vref *handlers* (fixnum-ashr header/unit           2)) handle-unit)
  176. (set (vref *handlers* (fixnum-ashr header/stack          2)) handle-stack)
  177. ;(set (vref *handlers* (fixnum-ashr header/weak-set       2)) handle-weak-set)
  178. ;(set (vref *handlers* (fixnum-ashr header/weak-alist     2)) handle-weak-alist)
  179. ;(set (vref *handlers* (fixnum-ashr header/weak-table     2)) handle-weak-table)
  180. ;(set (vref *handlers* (fixnum-ashr header/weak-cell      2)) handle-weak-cell)
  181.